home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / menubar.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  16.1 KB  |  437 lines
  1. ;; Menubar support.
  2. ;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
  3. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  19. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. (defvar default-menubar nil)
  22.  
  23. ;; this function is considered "part of the lexicon" by many,
  24. ;; so we'll leave it here.
  25. (defun kill-this-buffer ()    ; for the menubar
  26.   "Kill the current buffer."
  27.   (interactive)
  28.   (kill-buffer (current-buffer)))
  29.  
  30. ;; #### shouldn't this perhaps be `copy-tree'?
  31. (defun set-menubar (menubar)
  32.   "Set the default menubar to be MENUBAR.
  33. See `current-menubar' for a description of the syntax of a menubar."
  34.   (check-menu-syntax menubar t)
  35.   (setq-default current-menubar (copy-sequence menubar))
  36.   (set-menubar-dirty-flag))
  37.  
  38. (defun set-buffer-menubar (menubar)
  39.   "Set the buffer-local menubar to be MENUBAR.
  40. See `current-menubar' for a description of the syntax of a menubar."
  41.   (check-menu-syntax menubar t)
  42.   (make-local-variable 'current-menubar)
  43.   (setq current-menubar (copy-sequence menubar))
  44.   (set-menubar-dirty-flag))
  45.  
  46. (defun check-menu-syntax (menu &optional menubar-p)
  47.   ;; The C code does syntax checking on the value of `current-menubar',
  48.   ;; but it's better to do it early, before things have gotten messed up.
  49.   (if menubar-p
  50.       nil
  51.     (or (stringp (car menu))
  52.     (signal 'error
  53.         (list "menu name (first element) must be a string" menu)))
  54.     ;;(or (cdr menu) (signal 'error (list "menu is empty" menu)))
  55.     (setq menu (cdr menu)))
  56.   (let (menuitem item)
  57.     (while (keywordp (setq item (car menu)))
  58.       (or (memq item '(:config :included :filter))
  59.       (signal 'error
  60.           (list "menu keyword must be :config, :included, or :filter"
  61.             item)))
  62.       (if (or (not (cdr menu))
  63.           (vectorp (nth 1 menu))
  64.           (keywordp (nth 1 menu)))
  65.       (signal 'error (list "strange keyword value" item (nth 1 menu))))
  66.       (setq menu (nthcdr 2 menu)))
  67.     (while menu
  68.       (setq menuitem (car menu))
  69.       (cond
  70.        ((stringp menuitem)
  71.     (and (string-match "^\\(-+\\|=+\\):\\(.*\\)" menuitem)
  72.          (setq item (match-string 2 menuitem))
  73.          (or (member item '(;; Motif-compatible 
  74.                 "singleLine"
  75.                 "doubleLine"
  76.                 "singleDashedLine"
  77.                 "doubleDashedLine"
  78.                 "noLine"
  79.                 "shadowEtchedIn"
  80.                 "shadowEtchedOut"
  81.                 "shadowEtchedInDash"
  82.                 "shadowEtchedOutDash"
  83.                 ;; non-Motif (Lucid menubar widget only)
  84.                 "shadowDoubleEtchedIn"
  85.                 "shadowDoubleEtchedOut"
  86.                 "shadowDoubleEtchedInDash"
  87.                 "shadowDoubleEtchedOutDash"
  88.                 ))
  89.          (signal 'error (list "bogus separator style in menu item" item)))
  90.          ))
  91.        ((null menuitem)
  92.     (or menubar-p
  93.         (signal 'error (list "nil is only permitted in the top level of menubars"))))
  94.        ((consp menuitem)
  95.     (check-menu-syntax menuitem))
  96.        ((vectorp menuitem)
  97.     (let ((L (length menuitem))
  98.           plistp)
  99.       (and (< L 3)
  100.            (signal 'error
  101.                (list "button descriptors must be at least 3 long"
  102.                  menuitem)))
  103.       (setq plistp (or (>= L 5) (keywordp (aref menuitem 2))))
  104.       (or (stringp (aref menuitem 0))
  105.           (signal 'error
  106.               (list
  107.                "first element of a button must be a string (the label)"
  108.                menuitem)))
  109.       (or plistp
  110.           (< L 4)
  111.           (null (aref menuitem 3))
  112.           (stringp (aref menuitem 3))
  113.           (signal 'error
  114.               (list
  115.                "fourth element of a button must be a string (the label suffix)"
  116.                menuitem)))
  117.       (if plistp
  118.           (let ((i 2)
  119.             selp
  120.             style
  121.             item)
  122.         (while (< i L)
  123.           (setq item (aref menuitem i))
  124.           (cond ((not (memq item '(:active :suffix :keys :style
  125.                            :full :included :selected)))
  126.              (signal 'error
  127.                  (list (if (keywordp item)
  128.                        "unknown menu item keyword"
  129.                      "not a keyword")
  130.                        item menuitem)))
  131.             ((eq item :style)
  132.              (setq style (aref menuitem (1+ i)))
  133.              (or (memq style '(nil toggle radio button text))
  134.                  (signal 'error (list "unknown style" style
  135.                           menuitem))))
  136.             ((eq item :selected) (setq selp t))
  137.             )
  138.           (setq i (+ i (if (eq item :full) 1 2))))
  139.         (if (and selp (not (memq style '(toggle button radio))))
  140.             (signal 'error
  141.                 (list
  142.                  ":selected only makes sense with :style toggle, radio, or button"
  143.                  menuitem)))
  144.         )))
  145.     )
  146.        (t (signal 'error (list "unrecognised menu descriptor" menuitem))))
  147.       (setq menu (cdr menu)))))
  148.  
  149.  
  150. ;;; menu manipulation functions
  151.  
  152. (defun find-menu-item (menubar item-path-list &optional parent)
  153.   "Search MENUBAR for item given by ITEM-PATH-LIST starting from PARENT.
  154. Returns (ITEM . PARENT), where PARENT is the immediate parent of
  155.  the item found.
  156. If the item does not exist, the car of the returned value is nil.
  157. If some menu in the ITEM-PATH-LIST does not exist, an error is signalled."
  158.   (or (listp item-path-list)
  159.       (signal 'wrong-type-argument (list 'listp item-path-list)))
  160.   (or parent (setq item-path-list (mapcar 'downcase item-path-list)))
  161.   (if (not (consp menubar))
  162.       nil
  163.     (let ((rest menubar)
  164.       result)
  165.       (while (keywordp (car rest))
  166.     (setq rest (nthcdr 2 rest)))    
  167.       (while rest
  168.     (if (and (car rest)
  169.          (equal (car item-path-list)
  170.             (downcase (if (vectorp (car rest))
  171.                       (aref (car rest) 0)
  172.                     (if (stringp (car rest))
  173.                     (car rest)
  174.                       (car (car rest)))))))
  175.         (setq result (car rest) rest nil)
  176.       (setq rest (cdr rest))))
  177.       (if (cdr item-path-list)
  178.       (if (consp result)
  179.           (find-menu-item (cdr result) (cdr item-path-list) result)
  180.         (if result
  181.         (signal 'error (list (gettext "not a submenu") result))
  182.           (signal 'error (list (gettext "no such submenu") (car item-path-list)))))
  183.     (cons result parent)))))
  184.  
  185. (defun replace-list-element (list old new)
  186.   "Destructively replace OLD element with NEW element in LIST.
  187. Returns the new list."
  188.   (let ((place (memq old list)))
  189.     (if place
  190.     (setcar place new)
  191.       (signal 'error (list "cannot replace list element" list old new)))
  192.     list))
  193.  
  194. (defun add-menu-item-1 (leaf-p menu-path new-item before)
  195.   (if before (setq before (downcase before)))
  196.   (let* ((item-name (if (vectorp new-item) (aref new-item 0) (car new-item)))
  197.      (menubar current-menubar)
  198.      (menu (condition-case ()
  199.            (car (find-menu-item menubar menu-path))
  200.          (error nil)))
  201.      (item-found (cond ((not (listp menu))
  202.               (signal 'error (list (gettext "not a submenu")
  203.                        menu-path)))
  204.              (menu
  205.               (find-menu-item (cdr menu) (list item-name)))
  206.              (t
  207.               (find-menu-item menubar (list item-name)))
  208.              )))
  209.     (or menubar
  210.     (error "`current-menubar' is nil: can't add menus to it."))
  211.     (or menu
  212.     (let ((rest menu-path)
  213.           (so-far menubar))
  214.       (while rest
  215. ;;;        (setq menu (car (find-menu-item (cdr so-far) (list (car rest)))))
  216.         (setq menu
  217.           (if (eq so-far menubar)
  218.               (car (find-menu-item so-far (list (car rest))))
  219.             (car (find-menu-item (cdr so-far) (list (car rest))))))
  220.         (or menu
  221.         (let ((rest2 so-far))
  222.           (while (and (cdr rest2) (car (cdr rest2)))
  223.             (setq rest2 (cdr rest2)))
  224.           (setcdr rest2
  225.           (nconc (list (setq menu (list (car rest))))
  226.              (cdr rest2)))))
  227.         (setq so-far menu)
  228.         (setq rest (cdr rest)))))
  229.     (if (and item-found (car item-found))
  230.     ;; hack the item in place.
  231.     (if menu
  232.         (replace-list-element menu (car item-found) new-item)
  233.       (setq current-menubar (replace-list-element current-menubar
  234.                               (car item-found)
  235.                               new-item)))
  236.       ;; OK, we have to add the whole thing...
  237.       ;; if BEFORE is specified, try to add it there.
  238.       (or menu (setq menu current-menubar))
  239.       (if before
  240.       (setq before (car (find-menu-item (cdr menu) (list before)))))
  241.       (let ((rest menu)
  242.         (added-before nil))
  243.     (while rest
  244.       (if (eq before (car (cdr rest)))
  245.           (progn
  246.         (setcdr rest (cons new-item (cdr rest)))
  247.         (setq rest nil added-before t))
  248.         (setq rest (cdr rest))))
  249.     (if (not added-before)
  250.         ;; adding before the first item on the menubar itself is harder
  251.         (if (and (eq menu menubar) (eq before (car menu)))
  252.         (setq menu (cons new-item menu)
  253.               current-menubar menu)
  254.           ;; otherwise, add the item to the end.
  255.           (nconc menu (list new-item))))))
  256.     (set-menubar-dirty-flag)
  257.     new-item))
  258.  
  259. (defun add-menu-button (menu-path menu-leaf &optional before)
  260.   "Add a menu item to some menu, creating the menu first if necessary.
  261. If the named item exists already, it is changed.
  262. MENU-PATH identifies the menu under which the new menu item should be inserted.
  263.  It is a list of strings; for example, (\"File\") names the top-level \"File\"
  264.  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
  265. MENU-LEAF is a menubar leaf node.  See the documentation of `current-menubar'.
  266. BEFORE, if provided, is the name of a menu item before which this item should
  267.  be added, if this item is not on the menu already.  If the item is already
  268.  present, it will not be moved."
  269.   (add-menu-item-1 t menu-path menu-leaf before))
  270.  
  271. ;; I actually liked the old name better, but the interface has changed too
  272. ;; drastically to keep it. --Stig 
  273. (defun add-submenu (menu-path submenu &optional before)
  274.   "Add a menu to the menubar or one of its submenus.
  275. If the named menu exists already, it is changed.
  276. MENU-PATH identifies the menu under which the new menu should be inserted.
  277.  It is a list of strings; for example, (\"File\") names the top-level \"File\"
  278.  menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
  279.  If MENU-PATH is nil, then the menu will be added to the menubar itself.
  280. SUBMENU is the new menu to add.
  281.  See the documentation of `current-menubar' for the syntax.
  282. BEFORE, if provided, is the name of a menu before which this menu should
  283.  be added, if this menu is not on its parent already.  If the menu is already
  284.  present, it will not be moved."
  285.   (check-menu-syntax submenu nil)
  286.   (add-menu-item-1 nil menu-path submenu before))
  287.  
  288. (defun purecopy-menubar (x)
  289.   ;; this calls purecopy on the strings, and the contents of the vectors,
  290.   ;; but not on the vectors themselves, or the conses - those must be
  291.   ;; writable.
  292.   (cond ((vectorp x)
  293.      (let ((i (length x)))
  294.        (while (> i 0)
  295.          (aset x (1- i) (purecopy (aref x (1- i))))
  296.          (setq i (1- i))))
  297.      x)
  298.     ((consp x)
  299.      (let ((rest x))
  300.        (while rest
  301.          (setcar rest (purecopy-menubar (car rest)))
  302.          (setq rest (cdr rest))))
  303.      x)
  304.     (t
  305.      (purecopy x))))
  306.  
  307. (defun delete-menu-item (path)
  308.   "Remove the named menu item from the menu hierarchy.
  309. PATH is a list of strings which identify the position of the menu item in 
  310. the menu hierarchy.  The documentation of `add-submenu' describes menu-paths."
  311.   (let* ((pair (condition-case nil (find-menu-item current-menubar path)
  312.          (error nil)))
  313.      (item (car pair))
  314.      (parent (or (cdr pair) current-menubar)))
  315.     (if (not item)
  316.     nil
  317.       ;; the menubar is the only special case, because other menus begin
  318.       ;; with their name.
  319.       (if (eq parent current-menubar)
  320.       (setq current-menubar (delq item parent))
  321.     (delq item parent))
  322.       (set-menubar-dirty-flag)
  323.       item)))
  324.  
  325. (defun relabel-menu-item (path new-name)
  326.   "Change the string of the specified menu item.
  327. PATH is a list of strings which identify the position of the menu item in 
  328. the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
  329. under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
  330. menu item called \"Item\" under the \"Foo\" submenu of \"Menu\".
  331. NEW-NAME is the string that the menu item will be printed as from now on."
  332.   (or (stringp new-name)
  333.       (setq new-name (signal 'wrong-type-argument (list 'stringp new-name))))
  334.   (let* ((menubar current-menubar)
  335.          (pair (find-menu-item menubar path))
  336.          (item (car pair))
  337.          (menu (cdr pair)))
  338.     (or item
  339.         (signal 'error (list (if menu (gettext "No such menu item")
  340.                                (gettext "No such menu"))
  341.                              path)))
  342.     (if (and (consp item)
  343.              (stringp (car item)))
  344.         (setcar item new-name)
  345.       (aset item 0 new-name))
  346.     (set-menubar-dirty-flag)
  347.     item))
  348.  
  349. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  350. ;;
  351. ;; these are all bad style.  Why in the world would we put evaluable forms
  352. ;; into the menubar if we didn't want people to use 'em?
  353. ;; x-font-menu.el is the only known offender right now and that ought to be
  354. ;; rehashed a bit.
  355. ;; 
  356.  
  357. (defun enable-menu-item-1 (path toggle-p on-p)
  358.   (let (menu item)
  359.     (if (and (vectorp path) (> (length path) 2)) ; limited syntax checking...
  360.         (setq item path)
  361.       (let* ((menubar current-menubar)
  362.              (pair (find-menu-item menubar path)))
  363.         (setq item (car pair)
  364.               menu (cdr pair))
  365.         (or item
  366.             (signal 'error (list (if menu
  367.                                      "No such menu item"
  368.                                    "No such menu")
  369.                                  path)))
  370.         (if (consp item)
  371.             (error "%S is a menu, not a menu item" path))))
  372.     (if (or (> (length item) 4)
  373.             (and (symbolp (aref item 2))
  374.                  (= ?: (aref (symbol-name (aref item 2)) 0))))
  375.         ;; plist-like syntax
  376.         (let ((i 2)
  377.               (keyword (if toggle-p :selected :active))
  378.               (ok nil))
  379.           (while (< i (length item))
  380.             (cond ((eq (aref item i) keyword)
  381.                    (aset item (1+ i) on-p)
  382.                    (setq ok t)))
  383.             (setq i (+ i 2)))
  384.           (cond (ok nil)
  385.                 (toggle-p
  386.                  (signal 'error (list "not a toggle menu item" item)))
  387.                 (t
  388.                  ;; Need to copy the item to extend it, sigh...
  389.                  (let ((cons (memq item menu))
  390.                        (new-item (vconcat item (list keyword on-p))))
  391.                    (if cons
  392.                        (setcar cons (setq item new-item))
  393.                      (if menu
  394.                          (error "couldn't find %S on its parent?" item)
  395.                        (error "no %S slot to set: %S" keyword item)))))))
  396.       ;; positional syntax
  397.       (if toggle-p
  398.           (signal 'error (list "not a toggle menu item" item))
  399.         (aset item 2 on-p)))
  400.     (set-menubar-dirty-flag)
  401.     item))
  402.  
  403. (defun enable-menu-item (path)
  404.   "Make the named menu item be selectable.
  405. PATH is a list of strings which identify the position of the menu item in 
  406. the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
  407. under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
  408. menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
  409.   (enable-menu-item-1 path nil t))
  410.  
  411. (defun disable-menu-item (path)
  412.   "Make the named menu item be unselectable.
  413. PATH is a list of strings which identify the position of the menu item in 
  414. the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
  415. under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
  416. menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
  417.   (enable-menu-item-1 path nil nil))
  418.  
  419. (defun select-toggle-menu-item (path)
  420.   "Make the named toggle- or radio-style menu item be in the `selected' state.
  421. PATH is a list of strings which identify the position of the menu item in 
  422. the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
  423. under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
  424. menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
  425.   (enable-menu-item-1 path t t))
  426.  
  427. (defun deselect-toggle-menu-item (path)
  428.  "Make the named toggle- or radio-style menu item be in the `unselected' state.
  429. PATH is a list of strings which identify the position of the menu item in 
  430. the menu hierarchy.  (\"File\" \"Save\") means the menu item called \"Save\"
  431. under the toplevel \"File\" menu.  (\"Menu\" \"Foo\" \"Item\") means the 
  432. menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"."
  433.   (enable-menu-item-1 path t nil))
  434.  
  435.  
  436. (provide 'menubar)
  437.